home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / alpha.scm < prev    next >
Encoding:
Text File  |  1991-12-26  |  7.6 KB  |  273 lines
  1. ; File alpha.scm -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Alpha-conversion
  5.  
  6. ; Contexts
  7.  
  8. (define (note-context! context node)
  9.   (context node))
  10.  
  11. (define value-context     set-value-refs!)
  12. (define procedure-context set-proc-refs!)
  13. (define lvalue-context      set-assigned!)
  14. (define define-context      (lambda (var) var 'define-context))
  15. (define top-level-context (lambda (var) var 'top-level-context))
  16.  
  17. (define (lose context)  ;Ugh.   (let ((f (lambda () 1))) ((begin (foo) f)))
  18.   context ;lose
  19.   value-context)
  20.  
  21. (define @free-variables (make-fluid '()))
  22.  
  23.  
  24. ; Top-level entry point.
  25.  
  26. (define (alpha-top form s-env)
  27.   (alpha form s-env top-level-context))
  28.  
  29. ; Alphatization of a single scheme expression
  30.  
  31. (define @where (make-fluid '<top>))
  32.  
  33. (define (alpha form s-env context)
  34.   (with-values (lambda () (classify form s-env))
  35.     (lambda (class form s-env)
  36.       ((vector-ref alphatizers class) form s-env context))))
  37.  
  38. (define alphatizers (make-vector number-of-classes))
  39.  
  40. (define (define-alphatizer class proc)
  41.   (vector-set! alphatizers class proc))
  42.  
  43. (define-alphatizer class/literal
  44.   (lambda (exp s-env context)
  45.     s-env context            ;ignored
  46.     (make-constant exp #f)))
  47.  
  48. (define-alphatizer class/name
  49.   (lambda (exp s-env context)
  50.     (let ((denotation (lookup s-env exp)))
  51.       (cond ((node? denotation)
  52.          (if (local-variable? denotation)
  53.          (note-context! context denotation)
  54.          (let ((free (fluid @free-variables)))
  55.            (if (not (memq denotation free))
  56.                (set-fluid! @free-variables (cons denotation free)))))
  57.          denotation)
  58.         (else
  59.          (alpha (syntax-error "syntactic keyword in invalid position" exp)
  60.             s-env context))))))
  61.  
  62. (define-alphatizer class/application
  63.   (lambda (exp s-env context)
  64.     context                ;ignored
  65.     (make-call (alpha (car exp) s-env procedure-context)
  66.            (map (lambda (arg) (alpha arg s-env value-context))
  67.             (cdr exp)))))
  68.  
  69. ; The primitive special forms.
  70.  
  71. (define-alphatizer class/quote
  72.   (lambda (exp s-env context)
  73.     s-env context            ;ignored
  74.     (make-constant (cadr exp) #t)))
  75.  
  76. (define-alphatizer class/lambda
  77.   (lambda (exp s-env context)
  78.     (if (not (eq? context procedure-context))
  79.     ;; Not very accurate.  Improve later.
  80.     (for-each-local set-closed-over!
  81.             s-env))
  82.     (let ((s-env (rename-vars (proper-listify (cadr exp)) s-env)))
  83.       (make-lambda (new-names (cadr exp) s-env)
  84.            (alpha-body (cddr exp) s-env value-context)))))
  85.  
  86. (define-alphatizer class/letrec
  87.   (lambda (exp s-env context)
  88.     (let* ((specs (cadr exp))
  89.        (vars (map car specs))
  90.        (s-env (rename-vars vars s-env))
  91.        (new-vars (new-names vars s-env)))
  92.       (make-letrec new-vars
  93.            (map (lambda (spec)
  94.               (alpha (cadr spec) s-env value-context))
  95.             specs)
  96.            (alpha-body (cddr exp) s-env (lose context))))))
  97.  
  98. (define (alpha-body forms s-env context)
  99.   (with-values (lambda () (scan-body forms s-env))
  100.     (lambda (specs exps s-env)
  101.       (if (null? specs)
  102.       (alpha-beginify exps s-env context)
  103.       (let ((new-vars (map (lambda (spec)
  104.                  (make-local-variable (car spec)))
  105.                    specs)))
  106.         (for-each (lambda (spec var)
  107.             (define! s-env (car spec) var))
  108.               specs
  109.               new-vars)
  110.         (make-letrec new-vars
  111.              (map (lambda (spec)
  112.                 (alpha (cadr spec) (caddr spec) value-context))
  113.                   specs)
  114.              (alpha-beginify exps s-env (lose context))))))))
  115.  
  116. (define-alphatizer class/if
  117.   (lambda (exp s-env context)
  118.     (let ((test (alpha (cadr exp) s-env value-context))
  119.       (con  (alpha (caddr exp) s-env (lose context)))
  120.       (alt (alpha (let ((tail (cdddr exp)))
  121.             (if (null? tail)
  122.                 'schi:unspecified
  123.                 (car tail)))
  124.               s-env
  125.               (lose context))))
  126.       (make-if test con alt))))
  127.  
  128. (define-alphatizer class/set!
  129.   (lambda (exp s-env context)
  130.     context                ;ignored
  131.     (let ((lhs (alpha (cadr exp) s-env lvalue-context)))
  132.       (if (variable? lhs)
  133.       (make-set! lhs
  134.              (alpha (caddr exp) s-env value-context))
  135.       (error "invalid SET!" exp)))))
  136.  
  137. (define-alphatizer class/begin
  138.   (lambda (exp s-env context)
  139.     (alpha-beginify (cdr exp) s-env context)))
  140.  
  141. (define (alpha-beginify exp-list s-env context)
  142.   (cond ((null? (cdr exp-list))
  143.      (alpha (car exp-list) s-env context))
  144.     (else
  145.      (make-begin
  146.       (alpha (car exp-list)
  147.          s-env
  148.          (if (eq? context top-level-context)
  149.              context
  150.              value-context))
  151.       (alpha-beginify (cdr exp-list)
  152.               s-env
  153.               (if (eq? context top-level-context)
  154.                   context
  155.                   (lose context)))))))
  156.  
  157. (define-alphatizer class/define
  158.   (lambda (form s-env context)
  159.     (cond ((eq? context top-level-context)
  160.        (let ((var (alpha (define-form-lhs form) s-env define-context)))
  161.          (if (not (program-variable? var))
  162.          (error "This shouldn't happen" form))
  163.          ;; (set-status! var 'defined)
  164.          (let-fluid @where (program-variable-name var)
  165.             (lambda ()
  166.               (make-define var
  167.                        (alpha (define-form-rhs form)
  168.                           s-env value-context))))))
  169.       (else
  170.        (alpha (syntax-error "(define ...) disallowed in this context" form)
  171.           s-env context)))))
  172.  
  173. (define-alphatizer class/define-syntax
  174.   (lambda (form s-env context)
  175.     (cond ((eq? context top-level-context)
  176.        (process-define-syntax form s-env) ;side effect
  177.        (make-constant 'define-syntax #t))
  178.       (else 
  179.        (alpha (syntax-error
  180.            "(define-syntax ...) disallowed in this context" form)
  181.           s-env context)))))
  182.  
  183. (define (initialize-core-syntax env)
  184.   (define! env 'lambda          (make-special-operator class/lambda))
  185.   (define! env 'letrec          (make-special-operator class/letrec))
  186.   (define! env 'if          (make-special-operator class/if))
  187.   (define! env 'quote          (make-special-operator class/quote))
  188.   (define! env 'begin          (make-special-operator class/begin))
  189.   (define! env 'set!          (make-special-operator class/set!))
  190.   (define! env 'let-syntax    (make-special-operator class/let-syntax))
  191.   (define! env 'letrec-syntax (make-special-operator class/letrec-syntax))
  192.   (define! env 'define          (make-special-operator class/define))
  193.   (define! env 'define-syntax (make-special-operator class/define-syntax)))
  194.  
  195.  
  196. ; Revised^4 environment
  197.  
  198. (define revised^4-scheme-env
  199.   (make-program-env 'revised^4-scheme '()))
  200.  
  201. (initialize-core-syntax revised^4-scheme-env)
  202.  
  203. (define revised^4-scheme-module
  204.   (make-module 'revised^4-scheme    ;Exports everything
  205.            revised^4-scheme-sig
  206.            revised^4-scheme-env))
  207.  
  208. (define (built-in name)
  209.   (program-env-lookup revised^4-scheme-env name))
  210.  
  211.  
  212. ; Utilities:
  213.  
  214. (define (read-file filename)
  215.   (call-with-input-file filename
  216.     (lambda (i-port)
  217.       (let loop ((l '()))
  218.     (let ((form (read i-port)))
  219.       (cond ((eof-object? form) (reverse l))
  220.         (else
  221.          (loop (cons form l)))))))))
  222.  
  223. (define (note msg node)
  224.   (newline)
  225.   (display "** ")
  226.   (display msg)
  227.   (if node
  228.       (begin (display ": ")
  229.          (write (let-fluid @where '<note>
  230.                    (lambda ()
  231.                  (schemify-top node))))
  232.          (newline)
  233.          (display "   Location: ")
  234.          (write (fluid @where))))
  235.   (newline))
  236.  
  237. (define (syntax-error msg form)
  238.   (note msg form)
  239.   `(schi:scheme-error ',msg ',form))
  240.  
  241. ; Code generation utilities:
  242.  
  243. ; Unique id's
  244.  
  245. (define @unique-id (make-fluid 0))
  246.  
  247. (define (with-uid-reset thunk)
  248.   (let-fluid @unique-id 0 thunk))
  249.  
  250. (define (generate-uid)
  251.   (let ((uid (fluid @unique-id)))
  252.     (set-fluid! @unique-id (+ uid 1))
  253.     uid))
  254.  
  255. (define (make-name-from-uid name uid)  ;Best if it's not a legal Scheme symbol.
  256.   (lisp:intern
  257.    (string-append (name->string name)
  258.           "@"
  259.           (number->string uid '(heur)))
  260.    (fluid @target-package)))
  261.  
  262. (define (rename-vars names s-env)
  263.   (bind names (map make-local-variable names) s-env))
  264.  
  265. (define (new-names bvl env)
  266.   (map-bvl (lambda (var)
  267.          (lookup env var))
  268.        bvl))
  269.  
  270. (define (car-is? thing x)  ;useful for peephole optimizers
  271.   (and (pair? thing)
  272.        (eq? (car thing) x)))
  273.